
(***************************************************************************)

(* Appends a string to the specified text view. *)
let append_to_text_view (textview:GText.view) text =  
  let buffer = textview#buffer in
    buffer#insert ~iter:(buffer#end_iter) text;
    ();;

(* Clears the text in a text view. *)
let clear_text_view (textview:GText.view) =
  let buffer = textview#buffer in
  buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter;
  ();;

(***************************************************************************)

(* Builds the gui and connects it to the model. *)
let build_gui runner =

  (* Create the top-level window. *)
  let window = GWindow.window ~width:450
                              ~height:450
                              ~title:"Subprocess GUI"
                              ~border_width:0 () in

  (* Create a vbox to contain the menu bar, run bar, and the main pane. *)
  let vbox = GPack.vbox ~packing:window#add () in

  (* Create an about dialog to be activated through the help menu. *)
  let about_dialog = GWindow.about_dialog 
    ~name:"Subprocess GUI Demo" 
    ~comments:"Tom Lokovic (tdl@monkeyspeak.com)"
    ~version:"0.1"
    ~website:"http://www.monkeyspeak.com/"
    () in
      
  (* Create a menu bar and its entries. *)
  let menubar = GMenu.menu_bar ~packing:vbox#pack () in
  let menubar_factory = new GMenu.factory menubar in
  let accel_group = menubar_factory#accel_group in
  let file_menu = menubar_factory#add_submenu "File" in
  let file_factory = new GMenu.factory file_menu ~accel_group in
  let quit_menu_item = file_factory#add_item "Quit"
    ~callback:window#destroy in
  let help_menu = menubar_factory#add_submenu "Help" in
  let help_factory = new GMenu.factory help_menu ~accel_group in
  let about_menu_item = help_factory#add_item "About"
    ~callback:about_dialog#show in

  (* Create a horizontal bar with the entry box and run/cancel button. *)
  let run_bar = GPack.hbox ~packing:vbox#pack () in
  let run_entry = GEdit.entry ~packing:(run_bar#pack ~expand:true) () in
  let play_pixmap = GDraw.pixmap_from_xpm_d
    ~data:Icons.play_xpm ~window:window () in
  let stop_pixmap = GDraw.pixmap_from_xpm_d
    ~data:Icons.stop_xpm ~window:window () in
  let run_button = GButton.button ~packing:run_bar#pack () in
  let run_button_image = GMisc.pixmap play_pixmap ~packing:run_button#add () in

  (* Create a horizontally split pane that expands to fill as much of the
     main vbox as it can. *)
  let vpaned = GPack.paned `VERTICAL ~border_width:0
    ~packing:(vbox#pack ~expand:true) () in
    vpaned#set_position 200;

  (* Add a scrolling text view for stdout. *)
  let stdout_scroll = GBin.scrolled_window ~shadow_type:`ETCHED_IN
    ~packing:(vpaned#pack1 ~resize:true ~shrink:false)
    ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
  let stdout_view = GText.view ~editable:false ~packing:stdout_scroll#add () in

  (* Add a scrolling text view for stderr. *)
  let stderr_scroll = GBin.scrolled_window ~shadow_type:`ETCHED_IN
    ~packing:(vpaned#pack2 ~resize:false ~shrink:true)
    ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
  let stderr_view = GText.view ~editable:false ~packing:stderr_scroll#add () in

  (* Add a status bar. *)
  let statusbar = GMisc.statusbar ~packing:vbox#pack
    ~has_resize_grip:false() in
  let statusbar_context = statusbar#new_context ~name:"default" in

  (* Function to call whenever the runner has started a new process.
     Clears the stdout/stderr text views, sets the run button's icon
     to the red "X", and flashes a message to the status bar.
     
     This function should be called from the GUI thread. *)
  let on_subprocess_start () =
    clear_text_view stdout_view;
    clear_text_view stderr_view;
    run_button_image#set_pixmap stop_pixmap;
    statusbar_context#flash ~delay:3000 "Started." in
    
  (* Function to call whenever the runner's subprocess has stopped.
     Sets the run button's icon back to the green "play" icon, and
     flashes a message to the status bar.

     This function should be called from the GUI thread. *)
  let on_subprocess_stop status =
    run_button_image#set_pixmap play_pixmap;
    statusbar_context#flash ~delay:3000
      (Subprocess.string_of_status status) in
 
  (* Function to call whenever we receive a line of stdout from the
     subprocess.  Appends the line to the stdout text view.
     
     This function should be called from the GUI thread. *)
  let on_subprocess_stdout l = append_to_text_view stdout_view l in

  (* Function to call whenever we receive a line of stderr from the
     subprocess.  Appends the line to the stderr text view.
     
     This function should be called from the GUI thread. *)
  let on_subprocess_stderr l = append_to_text_view stderr_view l in
    
  (* Function to call whenever the user hits Enter in the command line
     text entry field.  If no subprocess is running, we send the new
     command line to the runner.  If a process is already running, we
     do nothing. *)
  let on_text_entry () =
    if not runner#is_running then
      runner#run run_entry#text
    else
      () in
    
  (* Function to call when the run/cancel button is pressed.  If a subprocess
     is already running, we kill it.  Otherwise we send the text entry's
     command line to the runner to start a new process. *)
  let on_run_button_click () =
    if runner#is_running then
      runner#kill()
    else
      runner#run run_entry#text in

  (* Function to call when the window is destroyed.  We clear the runner's
     callbacks, thus preventing it from trying to manipulate the GUI once
     the GUI has been torn down.  Then we tell GTK to quit its main loop. *)
  let on_window_destroy () =
    runner#reset_callbacks();
    GtkMain.Main.quit () in
    
  (* Connect the handlers.  The callbacks from the runner are invoked
     in another thread (not the GUI thread), so they should go through
     GtkThread.async, which ensures that the resulting GUI
     manipulations happen in the GUI thread.  (This is required for
     Windows threads, and is a good idea even on Unix, because it makes
     it easier to reason about the GUI behavior.)  We don't need to
     worry about this in the other direction, because the runner is
     threadsafe. *)
  runner#set_start_cb (fun _ -> GtkThread.async on_subprocess_start ());
  runner#set_stop_cb (fun s -> GtkThread.async on_subprocess_stop s);
  runner#set_stdout_cb (fun l -> GtkThread.async on_subprocess_stdout l);
  runner#set_stderr_cb (fun l -> GtkThread.async on_subprocess_stderr l);
  ignore(run_entry#connect#activate ~callback:on_text_entry);
  ignore(run_button#connect#clicked ~callback:on_run_button_click);
  ignore(window#connect#destroy ~callback:on_window_destroy);

  (* Show the window. *)
  window#show ();;

(***************************************************************************)

(* Intialize gtk.  We must do this before we start building the GUI. *)
ignore(GtkMain.Main.init ());

(* Create and initialize the subprocess runner, which acts as the MVC
   model in this app. *)
let runner = new Subprocess.runner in
  runner#init ();
  
  (* Build the GUI, and hook it up to the runner.  This function acts as the
     MVC controller in this app. *)
  build_gui runner;

  (* Run the gtk main loop.  We must use GtkThread.main() since we're using
     threads. *)
  GtkThread.main ();

  (* Deinitialize the runner, which kills the running process (if any)
     and joins its worker thread. *)
  runner#kill ();
  runner#deinit ();;
